home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / audacity / nyquist / sal-parse.lsp < prev    next >
Encoding:
Text File  |  2010-09-21  |  62.1 KB  |  1,819 lines
  1. ;; SAL parser -- replaces original pattern-directed parser with
  2. ;;    a recursive descent one
  3. ;;
  4. ;; Parse functions either parse correctly and return
  5. ;; compiled code as a lisp expression (which could be nil)
  6. ;; or else they call parse-error, which does not return
  7. ;; (instead, parse-error forces a return from parse)
  8. ;; In the original SAL parser, triples were returned
  9. ;; including the remainder if any of the tokens to be
  10. ;; parsed. In this parser, tokens are on the list
  11. ;; *sal-tokens*, and whatever remains on the list is
  12. ;; the list of unparsed tokens.
  13.  
  14. ;; scanning delimiters.
  15.  
  16. (setfn nreverse reverse)
  17.  
  18. (defconstant +quote+ #\")        ; "..." string 
  19. (defconstant +kwote+ #\')        ; '...' kwoted expr
  20. (defconstant +comma+ #\,)                ; positional arg delimiter
  21. (defconstant +pound+ #\#)                ; for bools etc
  22. (defconstant +semic+ #\;)        ; comment char
  23. (defconstant +lbrace+ #\{)               ; {} list notation 
  24. (defconstant +rbrace+ #\})
  25. (defconstant +lbrack+ #\[)               ; unused for now
  26. (defconstant +rbrack+ #\])
  27. (defconstant +lparen+ #\()               ; () expr and arg grouping
  28. (defconstant +rparen+ #\))
  29.  
  30. ;; these are defined so that SAL programs can name these symbols
  31. ;; note that quote(>) doesn't work, so you need quote(symbol:greater)
  32.  
  33. (setf symbol:greater '>)
  34. (setf symbol:less '<)
  35. (setf symbol:greater-equal '>=)
  36. (setf symbol:less-equal '<=)
  37. (setf symbol:equal '=)
  38. (setf symbol:not '!)
  39. (setf symbol:not-equal '/=)
  40.  
  41.  
  42. (defparameter +whites+ (list #\space #\tab #\newline (code-char 13)))
  43.  
  44. (defparameter +kwstyle+ (list :suffix #\:)) ; let's try dylan
  45.  
  46. (defparameter +operators+
  47.   ;; each op is: (<token-class> <sal-name> <lisp-form>)
  48.   '((:+ "+" sum)
  49.     (:- "-" diff)
  50.     (:* "*" mult)
  51.     (:/ "/" /)
  52.     (:% "%" rem)
  53.     (:^ "^" expt)
  54.     (:= "=" eql)   ; equality and assigment
  55.     (:!= "!=" not-eql)
  56.     (:< "<" <)
  57.     (:> ">" >)
  58.     (:<= "<=" <=) ; leq and assignment minimization
  59.     (:>= ">=" >=) ; geq and assignment maximization
  60.     (:~= "~=" equal) ; general equality
  61.     (:+= "+=" +=) ; assignment increment-and-store
  62.     (:-= "-=" -=) ; assignment increment-and-store
  63.     (:*= "*=" *=) ; assignment multiply-and-store
  64.     (:/= "/=" /=) ; assignment multiply-and-store
  65.     (:&= "&=" &=) ; assigment list collecting
  66.     (:@= "@=" @=) ; assigment list prepending
  67.     (:^= "^=" ^=) ; assigment list appending
  68.     (:! "!" not)
  69.     (:& "&" and)
  70.     (:\| "|" or)
  71.     (:~ "~" sal-stretch)
  72.     (:~~ "~~" sal-stretch-abs)
  73.     (:@ "@" sal-at)
  74.     (:@@ "@@" sal-at-abs)
  75.     ))
  76.  
  77. (setf *sal-local-variables* nil) ;; used to avoid warning about variable
  78.  ;; names when the variable has been declared as a local
  79.  
  80. (defparameter *sal-operators*
  81.   '(:+ :- :* :/ :% :^ := :!= :< :> :<= :>= :~= :+= :*= :&= :@= :^= :! :& :\|
  82.     :~ :~~ :@ :@@))
  83.  
  84. (defparameter +delimiters+
  85.   '((:lp #\()
  86.     (:rp #\))
  87.     (:lc #\{)                ; left curly
  88.     (:rc #\})
  89.     (:lb #\[)
  90.     (:rb #\])
  91.     (:co #\,)
  92.     (:kw #\')                ; kwote
  93.     (nil #\")                ; not token
  94.    ; (nil #\#)
  95.     (nil #\;)
  96.     ))
  97.  
  98. (setf *reserved-words* '((::+ ":+") (::- ":-") (::* ":*") (::/ ":/") (::= ":=")
  99.                          (::!= ":!=") (::< ":<") (::> ":>") (::<= ":<=")
  100.                          (::>= ":>=") (::~= ":~=") (::! ":!") (::& ":&")
  101.                          (::\| ":|") (:IF "if") (:THEN "then") (:ELSE "else")
  102.                          (:WHEN "when") (:UNLESS "unless") (:SET "set")
  103.                          (:= "=") (:+= "+=") (:*= "*=") (:&= "&=") (:@= "@=")
  104.                          (:^= "^=") (:<= "<=") (:>= ">=") (:PRINT "print")
  105.                          (:LOOP "loop")
  106.                          (:RUN "run") (:REPEAT "repeat") (:FOR "for")
  107.                          (:FROM "from") (:IN "in") (:BELOW "below") (:TO "to")
  108.                          (:ABOVE "above") (:DOWNTO "downto") (:BY "by")
  109.                          (:OVER "over") (:WHILE "while") (:UNTIL "until")
  110.                          (:FINALLY "finally") (:RETURN "return")
  111.                          (:WAIT "wait") (:BEGIN "begin") (:WITH "with")
  112.                          (:END "end") (:VARIABLE "variable")
  113.                          (:FUNCTION "function") (:PROCESS "process")
  114.                          (:CHDIR "chdir") (:DEFINE "define") (:LOAD "load")
  115.                          (:PLAY "play")
  116.                          (:EXEC "exec") (:exit "exit") (:DISPLAY "display")
  117.                          (:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@")))
  118.  
  119.  
  120. (setf *sal-fn-name* nil)
  121.  
  122. (defun make-sal-error (&key type text (line nil) start)
  123.   ; (error 'make-sal-error-was-called-break)
  124.   (list 'sal-error type text line start))
  125. (setfn sal-error-type cadr)
  126. (setfn sal-error-text caddr)
  127. (setfn sal-error-line cadddr)
  128. (defun sal-error-start (x) (cadddr (cdr x)))
  129. (defun is-sal-error (x) (and x (eq (car x) 'sal-error)))
  130. (defun sal-tokens-error-start (start)
  131.   (cond (start 
  132.          start)
  133.         (*sal-tokens*
  134.          (token-start (car *sal-tokens*)))
  135.         (t
  136.          (length *sal-input-text*))))
  137.  
  138.  
  139. (defmacro errexit (message &optional start)
  140.   `(parse-error (make-sal-error :type "parse"
  141.          :line *sal-input-text* :text ,message
  142.                  :start ,(sal-tokens-error-start start))))
  143.  
  144. (defmacro sal-warning (message &optional start)
  145.   `(pperror (make-sal-error :type "parse" :line *sal-input-text*
  146.                             :text ,message
  147.                             :start ,(sal-tokens-error-start start))
  148.             "warning"))
  149.  
  150. (setf *pos-to-line-source* nil)
  151. (setf *pos-to-line-pos* nil)
  152. (setf *pos-to-line-line* nil)
  153.  
  154. (defun pos-to-line (pos source)
  155.   ;; this is really inefficient to search every line from
  156.   ;; the beginning, so cache results and search forward
  157.   ;; from there if possible
  158.   (let ((i 0) (line-no 1)) ;; assume no cache
  159.     ;; see if we can use the cache
  160.     (cond ((and (eq source *pos-to-line-source*)
  161.                 *pos-to-line-pos* *pos-to-line-line*
  162.                 (>= pos *pos-to-line-pos*))
  163.            (setf i *pos-to-line-pos*)
  164.            (setf line-no *pos-to-line-line*)))
  165.     ;; count newlines up to pos
  166.     (while (< i pos)
  167.       (if (char= (char source i) #\newline)
  168.           (incf line-no))
  169.       (setf i (1+ i)))
  170.     ;; save results in cache
  171.     (setf *pos-to-line-source* source
  172.           *pos-to-line-pos* pos
  173.           *pos-to-line-line* line-no)
  174.     ;; return the line number at pos in source
  175.     line-no))
  176.  
  177.  
  178. ;; makes a string of n spaces, empty string if n <= 0
  179. (defun make-spaces (n)
  180.   (cond ((> n 16)
  181.          (let* ((half (/ n 2))
  182.                 (s (make-spaces half)))
  183.            (strcat s s (make-spaces (- n half half)))))
  184.         (t
  185.          (subseq "                " 0 (max n 0)))))
  186.  
  187.  
  188. (defun pperror (x &optional (msg-type "error"))
  189.   (let* ((source (sal-error-line x))
  190.      (llen (length source))
  191.          line-no
  192.          beg end)
  193.     ; (display "pperror" x (strcat "|" (sal-error-line x) "|"))
  194.     ;; isolate line containing error
  195.     (setf beg (sal-error-start x))
  196.     (setf beg (min beg (1- llen)))
  197.     (do ((i beg (- i 1))
  198.      (n nil)) ; n gets set when we find a newline
  199.     ((or (< i 0) n)
  200.      (setq beg (or n 0)))
  201.       (if (char= (char source i) #\newline)
  202.       (setq n (+ i 1))))
  203.     (do ((i (sal-error-start x) (+ i 1))
  204.      (n nil))
  205.     ((or (>= i llen) n)
  206.      (setq end (or n llen)))
  207.       (if (char= (char source i) #\newline)
  208.       (setq n i)))
  209.     (setf line-no (pos-to-line beg source))
  210.     ; (display "pperror" beg end (sal-error-start x))
  211.       
  212.     ;; print the error. include the specfic line of input containing
  213.     ;; the error as well as a line below it marking the error position
  214.     ;; with an arrow: ^
  215.     (let* ((pos (- (sal-error-start x) beg))
  216.        (line (if (and (= beg 0) (= end llen)) 
  217.              source
  218.              (subseq source beg end)))
  219.        (mark (make-spaces pos)))
  220.       (format t "~%>>> ~A ~A: ~A.~%>>> in ~A, line ~A, col ~A.~%~%~A~%~A^~%"
  221.               (sal-error-type x) msg-type (sal-error-text x)
  222.               *sal-input-file-name* line-no (1+ pos)
  223.               line mark)
  224. ;      (format t "~%>>> ~A error in \"~A\", line ~A, col ~A: ~A.~%~%~A~%~A^~%" 
  225. ;              (sal-error-type x) *sal-input-file-name* line-no pos
  226. ;          (sal-error-text x) line mark)
  227.       x)))
  228.  
  229.  
  230. ;;;
  231. ;;; the lexer. right now it assumes input string is complete and ready
  232. ;;; to be processed as a valid expression.
  233. ;;;
  234.  
  235. (defun advance-white (str white start end)
  236.   ;; skip "white" chars, where white can be a char, list of chars
  237.   ;; or predicate test
  238.   (do ((i start )
  239.        (p nil))
  240.       ((or p (if (< start end)
  241.          (not (< -1 i end))
  242.          (not (> i end -1))))
  243.        (or p end))
  244.     (cond ((consp white)
  245.        (unless (member (char str i) white :test #'char=)
  246.          (setq p i)))
  247.       ((characterp white)
  248.        (unless (char= (char str i) white)
  249.          (setq p i)))
  250.       ((functionp white)
  251.        (unless (funcall white (char str i))
  252.          (setq p i))))
  253.     (if (< start end)
  254.     (incf i)
  255.     (decf i))))
  256.  
  257.  
  258. (defun search-delim (str delim start end)
  259.   ;; find position of "delim" chars, where delim can be
  260.   ;; a char, list of chars or predicate test
  261.   (do ((i start (+ i 1))
  262.        (p nil))
  263.       ((or (not (< i end)) p)
  264.        (or p end))
  265.     (cond ((consp delim)
  266.        (if (member (char str i) delim :test #'char=)
  267.            (setq p i)))
  268.       ((characterp delim)
  269.        (if (char= (char str i) delim)
  270.            (setq p i)))
  271.       ((functionp delim)
  272.        (if (funcall delim (char str i))
  273.            (setq p i))))))
  274.  
  275.  
  276. ;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS 
  277. ;; OLD AND JUST KEPT HERE FOR REFERENCE
  278. #|
  279. (defun unbalanced-input (errf line toks par bra brk kwo)
  280.   ;; search input for the starting position of some unbalanced
  281.   ;; delimiter, toks is reversed list of tokens with something
  282.   ;; unbalanced
  283.   (let (char text targ othr levl pos)
  284.     (cond ((> par 0) (setq char #\( targ ':lp othr ':rp levl par))
  285.           ((< par 0) (setq char #\) targ ':rp othr ':lp levl 0))
  286.           ((> bra 0) (setq char #\{ targ ':lc othr ':rc levl bra))
  287.           ((< bra 0) (setq char #\} targ ':rc othr ':lc levl 0))
  288.           ((> brk 0) (setq char #\[ targ ':ls othr ':rs levl brk))
  289.           ((< brk 0) (setq char #\] targ ':rs othr ':ls levl 0))
  290.           ((> kwo 0) (setq char #\' targ ':kw othr ':kw levl kwo)))
  291.     (setq text (format nil "Unmatched '~A'" char))
  292.     ;; search for start of error in token list
  293.     (do ((n levl)
  294.          (tail toks (cdr tail)))
  295.         ((or (null tail) pos)
  296.          (or pos (error (format nil "Shouldn't! can't find op ~A in ~A."
  297.                                  targ (reverse toks)))))
  298.       (if (eql (token-type (car tail)) targ)
  299.           (if (= n levl)
  300.               (setq pos (token-start (car tail)))
  301.               (decf n))
  302.           (if (eql (token-type (car tail)) othr)
  303.               (incf n))))    
  304.     (errexit text pos)))
  305.  
  306.  
  307. (defun tokenize (str reserved error-fn)
  308.   ;&key (start 0) (end (length str)) 
  309.   ;         (white-space +whites+) (delimiters +delimiters+)
  310.   ;         (operators +operators+) (null-ok t)
  311.   ;              (keyword-style +kwstyle+) (reserved nil) 
  312.   ;         (error-fn nil)
  313.   ;         &allow-other-keys)
  314.   ;; return zero or more tokens or a sal-error
  315.   (let ((toks (list t))
  316.         (start 0)
  317.         (end (length str))
  318.         (all-delimiters +whites+)
  319.     (errf (or error-fn 
  320.           (lambda (x) (pperror x) (return-from tokenize x)))))
  321.     (dolist (x +delimiters+)
  322.       (push (cadr x) all-delimiters))
  323.     (do ((beg start)
  324.      (pos nil)
  325.      (all all-delimiters)
  326.      (par 0)
  327.      (bra 0)
  328.      (brk 0)
  329.      (kwo 0)
  330.      (tok nil)
  331.      (tail toks))
  332.     ((not (< beg end))
  333.      ;; since input is complete check parens levels.
  334.      (if (= 0 par bra brk kwo)
  335.          (if (null (cdr toks))
  336.          (list)
  337.          (cdr toks))
  338.          (unbalanced-input errf str (reverse (cdr toks)) 
  339.                    par bra brk kwo)))
  340.       (setq beg (advance-white str +whites+ beg end))
  341.       (setf tok
  342.     (read-delimited str :start beg :end end 
  343.             :white +whites+ :delimit all
  344.             :skip-initial-white nil :errorf errf))
  345.       ;; multiple values are returned, so split them here:
  346.       (setf pos (second tok)) ; pos is the end of the token (!)
  347.       (setf tok (first tok))
  348.  
  349.       ;; tok now string, char (delimiter), :eof or token since input
  350.       ;; is complete keep track of balancing delims
  351.       (cond ((eql tok +lbrace+) (incf bra))
  352.         ((eql tok +rbrace+) (decf bra))
  353.         ((eql tok +lparen+) (incf par))
  354.         ((eql tok +rparen+) (decf par))
  355.         ((eql tok +lbrack+) (incf brk))
  356.         ((eql tok +rbrack+) (decf brk))
  357.         ((eql tok +kwote+) (setq kwo (mod (+ kwo 1) 2))))
  358.       (cond ((eql tok ':eof)
  359.          (setq beg end))
  360.         
  361.         (t
  362.              ;; may have to skip over comments to reach token, so
  363.              ;; token beginning is computed by backing up from current
  364.              ;; position (returned by read-delimited) by string length
  365.              (setf beg (if (stringp tok)
  366.                            (- pos (length tok))
  367.                            (1- pos)))
  368.          (setq tok (classify-token tok beg str errf
  369.                        +delimiters+ +operators+
  370.                        +kwstyle+ reserved))
  371.              ;(display "classify-token-result" tok)
  372.          (setf (cdr tail) (list tok ))
  373.          (setf tail (cdr tail))
  374.          (setq beg pos))))))
  375. |#
  376.  
  377.  
  378. ;; old tokenize (above) counted delimiters to check for balance,
  379. ;; but that does not catch constructions like ({)}. I think
  380. ;; we could just leave this up to the parser, but this rewrite
  381. ;; uses a stack to check balanced parens, braces, quotes, etc.
  382. ;; The checking establishes at least some minimal global properties
  383. ;; of the input before evaluating anything, which might be good
  384. ;; even though it's doing some extra work. In fact, using a
  385. ;; stack rather than counts is doing even more work, but the
  386. ;; problem with counters is that some very misleading or just
  387. ;; plain wrong error messages got generated.
  388. ;;
  389. ;; these five delimiter- functions do checks on balanced parens,
  390. ;; braces, and brackets, leaving delimiter-mismatch set to bad
  391. ;; token if there is a mismatch
  392. (defun delimiter-init ()
  393.   (setf delimiter-stack nil)
  394.   (setf delimiter-mismatch nil))
  395. (defun delimiter-match (tok what)
  396.   (cond ((eql (token-string (first delimiter-stack)) what)
  397.          (pop delimiter-stack))
  398.         ((null delimiter-mismatch)
  399.          ;(display "delimiter-mismatch" tok)
  400.          (setf delimiter-mismatch tok))))
  401. (defun delimiter-check (tok)
  402.   (let ((c (token-string tok)))
  403.     (cond ((member c '(#\( #\{ #\[))
  404.            (push tok delimiter-stack))
  405.           ((eql c +rbrace+)
  406.            (delimiter-match tok +lbrace+))
  407.           ((eql c +rparen+)
  408.            (delimiter-match tok +lparen+))
  409.           ((eql c +rbrack+)
  410.            (delimiter-match tok +lbrack+)))))
  411. (defun delimiter-error (tok)
  412.   (errexit (format nil "Unmatched '~A'" (token-string tok))
  413.            (token-start tok)))
  414. (defun delimiter-finish ()
  415.   (if delimiter-mismatch
  416.       (delimiter-error delimiter-mismatch))
  417.   (if delimiter-stack
  418.       (delimiter-error (car delimiter-stack))))
  419. (defun tokenize (str reserved error-fn)
  420.   ;; return zero or more tokens or a sal-error
  421.   (let ((toks (list t))
  422.         (start 0)
  423.         (end (length str))
  424.         (all-delimiters +whites+)
  425.     (errf (or error-fn 
  426.           (lambda (x) (pperror x) (return-from tokenize x)))))
  427.     (dolist (x +delimiters+)
  428.       (push (cadr x) all-delimiters))
  429.     (delimiter-init)
  430.     (do ((beg start)
  431.      (pos nil)
  432.      (all all-delimiters)
  433.      (tok nil)
  434.      (tail toks))
  435.     ((not (< beg end))
  436.      ;; since input is complete check parens levels.
  437.          (delimiter-finish)
  438.          (if (null (cdr toks)) nil (cdr toks)))
  439.       (setq beg (advance-white str +whites+ beg end))
  440.       (setf tok
  441.     (read-delimited str :start beg :end end 
  442.             :white +whites+ :delimit all
  443.             :skip-initial-white nil :errorf errf))
  444.       ;; multiple values are returned, so split them here:
  445.       (setf pos (second tok)) ; pos is the end of the token (!)
  446.       (setf tok (first tok))
  447.  
  448.       (cond ((eql tok ':eof)
  449.          (setq beg end))
  450.         (t
  451.              ;; may have to skip over comments to reach token, so
  452.              ;; token beginning is computed by backing up from current
  453.              ;; position (returned by read-delimited) by string length
  454.              (setf beg (if (stringp tok)
  455.                            (- pos (length tok))
  456.                            (1- pos)))
  457.          (setq tok (classify-token tok beg str errf
  458.                        +delimiters+ +operators+
  459.                        +kwstyle+ reserved))
  460.              (delimiter-check tok)
  461.              ;(display "classify-token-result" tok)
  462.          (setf (cdr tail) (list tok ))
  463.          (setf tail (cdr tail))
  464.          (setq beg pos))))))
  465.  
  466.  
  467. (defun read-delimited (input &key (start 0) end (null-ok t)
  468.                (delimit +delims+) ; includes whites...
  469.                (white +whites+)
  470.                (skip-initial-white t)
  471.                (errorf #'pperror))
  472.   ;; read a substring from input, optionally skipping any white chars
  473.   ;; first. reading a comment delim equals end-of-line, input delim
  474.   ;; reads whole input, pound reads next token. call errf if error
  475.   ;(FORMAT T "~%READ-DELIMITED: ~S :START ~S :END ~S" input start end)
  476.   (let ((len (or end (length input))))
  477.     (while t ;; loop over comment lines
  478.       (when skip-initial-white
  479.         (setq start (advance-white input white start len)))
  480.         (if (< start len)
  481.       (let ((char (char input start)))
  482.         (setq end (search-delim input delimit start len))
  483.             (if (equal start end)        ; have a delimiter
  484.            (cond ((char= char +semic+)
  485.                       ;; comment skips to next line and trys again...
  486.                       (while (and (< start len)
  487.                                   (char/= (char input start) #\newline))
  488.                         (incf start))
  489.                       (cond ((< start len) ;; advance past comment and iterate
  490.                              (incf start)
  491.                              (setf skip-initial-white t))
  492.                             (null-ok
  493.                              (return (list ':eof end)))
  494.                             (t
  495.                              (errexit "Unexpected end of input"))))
  496. ;             ((char= char +pound+)
  497. ;              ;; read # dispatch
  498. ;              (read-hash input delimit start len errorf))
  499.              ((char= char +quote+)
  500.               ;; input delim reads whole input
  501.               (return (sal:read-string input delimit start len errorf)))
  502.              ((char= char +kwote+)
  503.               (errexit "Illegal delimiter" start))
  504.              (t ;; all other delimiters are tokens in and of themselves
  505.               (return (list char (+ start 1)))))
  506.             ; else part of (equal start end), so we have token before delimiter
  507.               (return (list (subseq input start end) end))))
  508.         ; else part of (< start len)...
  509.       (if null-ok 
  510.               (return (list ':eof end))
  511.           (errexit "Unexpected end of input" start))))))
  512.  
  513.  
  514. (defparameter hash-readers 
  515.   '(( #\t sal:read-bool)
  516.     ( #\f sal:read-bool)
  517.     ( #\? read-iftok)
  518.     ))
  519.  
  520.  
  521. (defun read-hash (str delims pos len errf)
  522.   (let ((e (+ pos 1)))
  523.     (if (< e len)
  524.     (let ((a (assoc (char str e) hash-readers)))
  525.       (if (not a)
  526.           (errexit "Illegal # character" e)
  527.           (funcall (cadr a) str delims e len errf)))
  528.     (errexit "Missing # character" pos))))
  529.  
  530.  
  531. (defun read-iftok (str delims pos len errf)
  532.   str delims len errf
  533.   (list (make-token :type ':? :string "#?" :lisp 'if
  534.              :start (- pos 1))
  535.     (+ pos 1)))
  536.  
  537. ; (sal:read-string str start len)
  538.  
  539. (defun sal:read-bool (str delims pos len errf)
  540.   delims len errf
  541.   (let ((end (search-delim str delims pos len)))
  542.     (unless (= end (+ pos 1))
  543.       (errexit "Illegal # expression" (- pos 1)))
  544.     (list (let ((t? (char= (char str pos) #\t) ))
  545.             (make-token :type ':bool 
  546.                            :string (if t? "#t" "#f")
  547.                :lisp t?
  548.                :start (- pos 1)))
  549.           (+ pos 1))))
  550.  
  551.  
  552. (defun sal:read-string (str delims pos len errf)
  553.   (let* ((i (1+ pos)) ; i is index into string; start after open quote
  554.          c c2; c is the character at str[i]
  555.          (string (make-string-output-stream)))
  556.     ;; read string, processing escaped characters
  557.     ;; write the chars to string until end quote is found
  558.     ;; then retrieve the string. quotes are not included in result token
  559.  
  560.     ;; in the loop, i is the next character location to examine
  561.     (while (and (< i len) 
  562.                 (not (char= (setf c (char str i)) +quote+)))
  563.       (if (char= c #\\) ;; escape character, does another character follow this?
  564.           (cond ((< (1+ i) len)
  565.                  (incf i) ;; yes, set i so we'll get the escaped char
  566.                  (setf c2 (char str i))
  567.                  (setf c (assoc c2 `((#\n . #\newline) (#\t . #\tab) 
  568.                                      (#\r . ,(char "\r" 0))
  569.                                      (#\f . ,(char "\f" 0)))))
  570.                  (setf c (if c (cdr c) c2))) ;; use c2 if c wasn't listed
  571.                 (t ;; no, we've hit the end of input too early
  572.                  (errexit "Unmatched \"" i))))
  573.       ;; we're good to take this character and move on to the next one
  574.       (write-char c string)
  575.       (incf i))
  576.     ;; done with loop, so either we're out of string or we found end quote
  577.     (if (>= i len) (errexit "Unmatched \"" i))
  578.     ;; must have found the quote
  579.     (setf string (get-output-stream-string string))
  580.     (list (make-token :type :string :start pos :string string :lisp string)
  581.           (1+ i))))
  582.  
  583. ;;;
  584. ;;; tokens
  585. ;;;
  586.  
  587. (defun make-token (&key (type nil) (string "") start (info nil) lisp)
  588.   (list :token type string start info lisp))
  589. (setfn token-type cadr)
  590. (setfn token-string caddr)
  591. (defun token-start (x) (cadddr x))
  592. (defun token-info (token) (car (cddddr token)))
  593. (defun token-lisp (token) (cadr (cddddr token)))
  594. (defmacro set-token-type (tok val) `(setf (car (cdr ,tok)) ,val))
  595. (defmacro set-token-lisp (tok val) `(setf (car (cdr (cddddr ,tok))) ,val))
  596. (defun tokenp (tok) (and (consp tok) (eq (car tok) :token)))
  597.  
  598. (defun token=? (tok op)
  599.   (if (tokenp tok)
  600.       (equal (token-type tok) op)
  601.       (eql tok op)))
  602.  
  603. (defmethod token-print (obj stream)
  604.   (let ((*print-case* ':downcase))
  605.     (format stream "#<~s ~s>" 
  606.         (token-type obj) 
  607.         (token-string obj))))
  608.  
  609. (defun parse-token ()
  610.   (prog1 (car *sal-tokens*)
  611.          (setf *sal-tokens* (cdr *sal-tokens*))))
  612.  
  613. ;;;
  614. ;;; token classification. types not disjoint!
  615. ;;;
  616.  
  617. (defun classify-token (str pos input errf delims ops kstyle res)
  618.   (let ((tok nil))
  619.     (cond ((characterp str)
  620.        ;; normalize char delimiter tokens
  621.        (setq tok (delimiter-token? str pos input errf delims)))
  622.       ((stringp str)
  623.        (setq tok (or (number-token? str pos input errf)
  624.              (operator-token? str pos input errf ops)
  625.              (keyword-token? str pos input errf kstyle)
  626.              (class-token? str pos input errf res)
  627.              (reserved-token? str pos input errf res)
  628.              (symbol-token? str pos input errf)
  629.              ))
  630.        (unless tok
  631.          (errexit "Not an expression or symbol" pos)))
  632.       (t (setq tok str)))
  633.     tok))
  634.  
  635.  
  636. (defun delimiter-token? (str pos input errf delims)
  637.   (let ((typ (member str delims :test (lambda (a b) (char= a (cadr b))))))
  638.     ;; member returns remainder of the list
  639.     ;(display "delimiter-token?" str delims typ)
  640.     (if (and typ (car typ) (caar typ))
  641.     (make-token :type (caar typ) :string str
  642.                :start pos)
  643.     (+ (break) (errexit "Shouldn't: non-token delimiter" pos)))))
  644.  
  645.  
  646. (defun string-to-number (s)
  647.   (read (make-string-input-stream s)))
  648.  
  649.  
  650. (defun number-token? (str pos input errf)
  651.   errf input
  652.   (do ((i 0 (+ i 1))
  653.        (len (length str))
  654.        (c nil)
  655.        (dot 0)
  656.        (typ ':int)
  657.        (sig 0)
  658.        (sla 0)
  659.        (dig 0)
  660.        (non nil))
  661.       ((or (not (< i len)) non)
  662.        (if non nil
  663.        (if (> dig 0) 
  664.            (make-token :type typ :string str
  665.                   :start pos :lisp (string-to-number str))
  666.            nil)))
  667.     (setq c (char str i))
  668.     (cond ((member c '(#\+ #\-))
  669.        (if (> i 0) (setq non t)
  670.            (incf sig)))
  671.       ((char= c #\.)
  672.        (if (> dot 0) (setq non t)
  673.            (if (> sla 0) (setq non t)
  674.            (incf dot))))
  675. ; xlisp does not have ratios
  676. ;      ((char= c #\/)
  677. ;       (setq typ ':ratio)
  678. ;       (if (> sla 0) (setq non t)
  679. ;           (if (= dig 0) (setq non t)
  680. ;           (if (> dot 0) (setq non t)
  681. ;               (if (= i (1- len)) (setq non t)
  682. ;               (incf sla))))))
  683.       ((digit-char-p c)
  684.        (incf dig)
  685.        (if (> dot 0) (setq typ ':float)))
  686.       (t (setq non t)))))
  687.  
  688. #||
  689. (number-token? "" 0 "" #'pperror)
  690. (number-token? " " 0 "" #'pperror)
  691. (number-token? "a"  0 "" #'pperror)
  692. (number-token? "1" 0 "" #'pperror)
  693. (number-token? "+" 0 "" #'pperror)
  694. (number-token? "-1/2" 0 "" #'pperror)
  695. (number-token? "1." 0 "" #'pperror)
  696. (number-token? "1.." 0 "" #'pperror)
  697. (number-token? ".1." 0 "" #'pperror)
  698. (number-token? ".1" 0 "" #'pperror)
  699. (number-token? "-0.1" 0 "" #'pperror)
  700. (number-token? "1/2" 0 "" #'pperror)
  701. (number-token? "1//2" 0 "" #'pperror)
  702. (number-token? "/12" 0 "" #'pperror)
  703. (number-token? "12/" 0 "" #'pperror)
  704. (number-token? "12/1" 0 "" #'pperror)
  705. (number-token? "12./1" 0 "" #'pperror)
  706. (number-token? "12/.1" 0 "" #'pperror)
  707. ||#
  708.  
  709. (defun operator-token? (str pos input errf ops)
  710.   ;; tok can be string or char
  711.   (let ((typ (member str ops :test (lambda (a b) (equal a (cadr b))))))
  712.     (cond (typ 
  713.            (setf typ (car typ)) ;; member returns remainder of list
  714.            (make-token :type (car typ) :string str
  715.                :start pos :lisp (or (third typ)
  716.                         (read-from-string str)))))))
  717.  
  718. (defun str-to-keyword (str)
  719.   (intern (strcat ":" (string-upcase str))))
  720.  
  721.  
  722. (defun keyword-token? (tok pos input errf style)
  723.   (let* ((tlen (length tok))
  724.      (keys (cdr style))
  725.      (klen (length keys)))
  726.     (cond ((not (< klen tlen)) nil)
  727.       ((eql (car style) ':prefix)
  728.        (do ((i 0 (+ i 1))
  729.         (x nil))
  730.            ((or (not (< i klen)) x)
  731.         (if (not x)
  732.             (let ((sym (symbol-token? (subseq tok i)
  733.                           pos input errf )))
  734.               (cond (sym
  735.                              (set-token-type sym ':key)
  736.                              (set-token-lisp sym
  737.                                 (str-to-keyword (token-string sym)))
  738.                              sym)))
  739.             nil))
  740.          (unless (char= (char tok i) (nth i keys))
  741.            (setq x t))))
  742.       ((eql (car style) ':suffix)
  743.        (do ((j (- tlen klen) (+ j 1))
  744.         (i 0 (+ i 1))
  745.         (x nil))
  746.            ((or (not (< i klen)) x)
  747.         (if (not x)
  748.             (let ((sym (symbol-token? (subseq tok 0 (- tlen klen))
  749.                           pos input errf )))
  750.               (cond (sym
  751.                              (set-token-type sym ':key)
  752.                              (set-token-lisp sym
  753.                                 (str-to-keyword (token-string sym)))
  754.                              sym)))
  755.             nil))
  756.          (unless (char= (char tok j) (nth i keys))
  757.            (setq x t)))))))
  758.  
  759.  
  760. (setfn alpha-char-p both-case-p)
  761.  
  762.  
  763. (defun class-token? (str pos input errf res)
  764.   res
  765.   (let ((a (char str 0)))
  766.     (if (char= a #\<)
  767.     (let* ((l (length str))
  768.            (b (char str (- l 1))))
  769.       (if (char= b #\>)
  770.           (let ((tok (symbol-token? (subseq str 1 (- l 1))
  771.                     pos input errf)))
  772.         ;; class token has <> removed!
  773.         (if tok (progn (set-token-type tok ':class)
  774.                    tok)
  775.             (errexit "Not a class identifer" pos)))
  776.           (errexit "Not a class identifer" pos)))
  777.     nil)))
  778.  
  779. ; (keyword-token? ":asd" '(:prefix #\:))
  780. ; (keyword-token? "asd" KSTYLE)
  781. ; (keyword-token? "asd:"  KSTYLE)
  782. ; (keyword-token? "123:"  KSTYLE)
  783. ; (keyword-token? ":foo" '(:prefix #\:))
  784. ; (keyword-token? "foo=" '(:suffix #\=))
  785. ; (keyword-token? "--foo" '(:prefix #\- #\-))
  786. ; (keyword-token? ":123" '(:suffix #\:))
  787. ; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol
  788.  
  789.  
  790. (defun reserved-token? (str pos input errf reserved)
  791.   errf input
  792.   (let ((typ (member str reserved :test (lambda (a b) (equal a (cadr b))))))
  793.     (if typ 
  794.     (make-token :type (caar typ) :string str
  795.                :start pos)
  796.     nil)))
  797.  
  798.  
  799. (defun sal-string-to-symbol (str)
  800.   (let ((sym (intern (string-upcase str)))
  801.         sal-sym)
  802.     (cond ((and sym ;; (it might be "nil")
  803.                 (setf sal-sym (get sym :sal-name)))
  804.            sal-sym)
  805.           (t sym))))
  806.  
  807.  
  808. (putprop 'simrep 'sal-simrep :sal-name)
  809. (putprop 'seqrep 'sal-seqrep :sal-name)
  810.  
  811. (defun contains-op-char (s)
  812.   ;; assume most identifiers are very short, so we search
  813.   ;; over identifier letters, not over operator characters
  814.   ;; Minus (-) is so common, we don't complain about it.
  815.   (dotimes (i (length s))
  816.     (if (string-search (subseq s i (1+ i)) "*/+=<>!%^&|")
  817.         (return t))))
  818.  
  819. (defun test-for-suspicious-symbol (token)
  820.   ;; assume token is of type :id
  821.   (let ((sym (token-lisp token))
  822.         (str (token-string token))
  823.         (pos (token-start token)))
  824.     (cond ((and sym  ; nil is not suspicious, but it's not "boundp"
  825.                 (not (fboundp sym)) ; existing functions not suspicious
  826.                 (not (boundp sym))  ; existing globals not suspicious
  827.                 (not (member sym *sal-local-variables*))
  828.                 (contains-op-char str)) ; suspicious if embedded operators
  829.            (sal-warning
  830.              (strcat "Identifier contains operator character(s).\n"
  831.                      "        Perhaps you omitted spaces around an operator")
  832.              pos)))))
  833.  
  834.  
  835. (defun symbol-token? (str pos input errf)
  836.   ;; if a potential symbol is preceded by #, drop the #
  837.   (if (and (> (length str) 1)
  838.            (char= (char str 0) #\#))
  839.       ;; there are a couple of special cases: SAL defines #f and #?
  840.       (cond ((equal str "#f")
  841.              (return-from symbol-token?
  842.                (make-token :type ':id :string str :start pos :lisp nil)))
  843.             ((equal str "#?")
  844.              (return-from symbol-token?
  845.                (make-token :type ':id :string str :start pos :lisp 'if)))
  846.             (t
  847.              (setf str (subseq str 1)))))
  848.   ;; let's insist on at least one letter for sanity's sake
  849.   ;; exception: allow '-> because it is used in markov pattern specs
  850.   (do ((i 0 (+ i 1))  ; i is index into string
  851.        (bad "Not an expression or symbol")
  852.        (chr nil)
  853.        (ltr 0)        ; ltr is count of alphabetic letters in string
  854.        (dot nil)      ; dot is index of "."
  855.        (pkg nil)      ; pkg is index if package name "xxx:" found
  856.        (len (length str))
  857.        (err nil))
  858.       ;; loop ends when i is at end of string or when err is set
  859.       ((or (not (< i len)) err)
  860.        (if (or (> ltr 0) ; must be at least one letter, or
  861.                (equal str "->")) ; symbol can be "->"
  862.        (let ((info ()) sym)
  863.          (if pkg (push (cons ':pkg pkg) info))
  864.          (if dot (push (cons ':slot dot) info))         
  865.              ;(display "in symbol-token?" str)
  866.              (setf sym (sal-string-to-symbol str))
  867.          (make-token :type ':id :string str
  868.                 :info info :start pos
  869.                             :lisp sym))
  870.        nil))
  871.     (setq chr (char str i))
  872.     (cond ((alpha-char-p chr) (incf ltr))
  873. ; need to allow arbitrary lisp symbols
  874. ;      ((member chr '(#\* #\+)) ;; special variable names can start/end 
  875. ;       (if (< 0 i (- len 2))   ;; with + or *
  876. ;           (errexit bad pos)))
  877.       ((char= chr #\/) ;; embedded / is not allowed
  878.        (errexit bad pos))
  879.       ;((char= chr #\-) ;; hyphens are allowed anywhere in symbol
  880.       ; (if (= ltr 0) 
  881.       ;     (errexit errf input bad pos )
  882.       ;     (setq ltr 0)
  883.       ;     ))
  884.       ((char= chr #\:)
  885.            ; allowable forms are :foo, foo:bar, :foo:bar
  886.        (if (> i 0) ;; lisp keyword symbols ok
  887.            (cond ((= ltr 0)
  888.               (errexit bad pos))
  889.              ((not pkg)
  890.               (setq pkg i))
  891.              (t (errexit errf input
  892.                  (format nil "Too many colons in ~s" str)
  893.                  pos))))
  894.        (setq ltr 0))
  895.       ((char= chr #\.)
  896.        (if (or dot (= i 0) (= i (- len 1)))
  897.            (errexit bad pos)
  898.            (progn (setq dot i) (setq ltr 0)))))))
  899.  
  900.  
  901. ; (let ((i "foo")) (symbol-token? i 0 i #'pperror))
  902. ; (let ((i "foo..bar")) (symbol-token? i 0 i #'pperror))
  903. ; (let ((i ".bar")) (symbol-token?  i 0 i #'pperror))
  904. ; (let ((i "bar.")) (symbol-token?  i 0 i #'pperror))
  905. ; (let ((i "1...")) (symbol-token?  i 0 i #'pperror))
  906. ; (let ((i "a1..." )) (symbol-token? i 0 i #'pperror))
  907. ; (let ((i  "a{b")) (symbol-token? i 0 i #'pperror))
  908. ; (let ((i "foo-bar")) (symbol-token?  i 0 i #'pperror))
  909. ; (let ((i "123-a")) (symbol-token?  i 0 i #'pperror))
  910. ; (let ((i "1a23-a")) (symbol-token?  i 0 i #'pperror))
  911. ; (let ((i "*foo*")) (symbol-token?  i 0 i #'pperror))
  912. ; (let ((i "+foo+")) (symbol-token?  i 0 i #'pperror))
  913. ; (let ((i "foo+bar")) (symbol-token?  i 0 i #'pperror))
  914. ; (let ((i "foo/bar")) (symbol-token?  i 0 i #'pperror))
  915.  
  916. ; (let ((i ":bar")) (symbol-token?  i 0 i #'pperror))
  917. ; (let ((i "::bar")) (symbol-token?  i 0 i #'pperror))
  918. ; (let ((i "foo:bar")) (symbol-token?  i 0 i #'pperror))
  919. ; (let ((i "cl-user:bar")) (symbol-token?  i 0 i #'pperror))
  920. ; (let ((i "cl-user::bar")) (symbol-token?  i 0 i #'pperror))
  921. ; (tokenize "aaa + bbb \"asdasdd\" aaa(1,2,3)")
  922. ; (tokenize "aaa+bbb \"asdasdd\" aaa(1,2,3)")
  923.  
  924.  
  925. (setf *in-sal-parser* nil)
  926.  
  927. ;; line number info for debugging
  928. (setf *sal-line-number-info* t)
  929. (setf *sal-line* 0)
  930.  
  931. (defun add-line-info-to-expression (expr token)
  932.   (let (line-no)
  933.     (cond ((and token ;; null token means do not change expr
  934.                 *sal-line-number-info* ;; is this feature enabled?
  935.                 (stringp *sal-input-text*))
  936.            ;; first, get line number
  937.            (setf line-no (pos-to-line (token-start token) *sal-input-text*))
  938.            `(prog2 (setf *sal-line* ,line-no) ,expr))
  939.           (t expr))))
  940.  
  941. ;; single statement is handled just like an expression
  942. (setfn add-line-info-to-stmt add-line-info-to-expression)
  943.  
  944. ;; list of statements is simple to handle: prepend SETF
  945. (defun add-line-info-to-stmts (stmts token)
  946.   (let (line-no)
  947.     (cond ((and *sal-line-number-info* ;; is this feature enabled?
  948.                 (stringp *sal-input-text*))
  949.            (setf line-no (pos-to-line (token-start token) *sal-input-text*))
  950.            (cons `(setf *sal-line* ,line-no) stmts))
  951.           (t stmts))))
  952.  
  953.  
  954. ;; PARSE-ERROR -- print error message, return from top-level
  955. ;;
  956. (defun parse-error (e)
  957.   (unless (sal-error-line e)
  958.     (setf (sal-error-line e) *sal-input*))
  959.   (pperror e)
  960.   (return-from sal-parse (values nil e *sal-tokens*)))
  961.  
  962.  
  963. ;; SAL-PARSE -- parse string or token input, translate to Lisp
  964. ;;
  965. ;; If input is text, *sal-input-text* is set to the text and
  966. ;;   read later (maybe) by ERREXIT. 
  967. ;; If input is a token list, it is assumed these are leftovers
  968. ;;   from tokenized text, so *sal-input-text* is already valid.
  969. ;; *Therfore*, do not call sal-parse with tokens unless 
  970. ;;   *sal-input-text* is set to the corresponding text.
  971. ;;
  972. (defun sal-parse (grammar pat input multiple-statements file)
  973.   (progv '(*sal-input-file-name*) (list file)
  974.     (let (rslt expr rest)
  975.       ; ignore grammar and pat (just there for compatibility)
  976.       ; parse input and return lisp expression
  977.       (cond ((stringp input)
  978.              (setf *sal-input-text* input)
  979.              (setq input (tokenize input *reserved-words* #'parse-error))))
  980.       (setf *sal-input* input) ;; all input
  981.       (setf *sal-tokens* input) ;; current input
  982.       (cond ((null input)
  983.              (values t nil nil)) ; e.g. comments compile to nil
  984.             (t
  985.              (setf rslt (or (maybe-parse-command)
  986.                             (maybe-parse-block)
  987.                             (maybe-parse-conditional)
  988.                             (maybe-parse-assignment)
  989.                             (maybe-parse-loop)
  990.                             (maybe-parse-exec)
  991.                             (maybe-parse-exit)
  992.                             (errexit "Syntax error")))
  993.              ;; note: there is a return-from parse in parse-error that
  994.              ;; returns (values nil error <unparsed-tokens>)
  995.              (cond ((and *sal-tokens* (not multiple-statements))
  996.                     (errexit "leftover tokens")))
  997.                     ;((null rslt)
  998.                     ; (errexit "nothing to compile")))
  999.              (values t rslt *sal-tokens*))))))
  1000.  
  1001.  
  1002. ;; TOKEN-IS -- test if the type of next token matches expected type(s)
  1003. ;;
  1004. ;; type can be a list of possibilities or just a symbol
  1005. ;; Usually, suspicious-id-warn is true by default, and any symbol
  1006. ;; with embedded operator symbols, e.g. x+y results in a warning
  1007. ;; that this is an odd variable name. But if the symbol is declared
  1008. ;; as a local, a parameter, a function name, or a global variable,
  1009. ;; then the warning is supressed.
  1010. ;;
  1011. (defun token-is (type &optional (suspicious-id-warn t))
  1012.   (let ((token-type
  1013.          (if *sal-tokens* (token-type (car *sal-tokens*)) nil))
  1014.         rslt)
  1015.     ; input can be list of possible types or just a type:
  1016.     (setf rslt (or (and (listp type) 
  1017.                         (member token-type type))
  1018.                    (and (symbolp type) (eq token-type type))))
  1019.     ; test if symbol has embedded operator characters:
  1020.     (cond ((and rslt suspicious-id-warn (eq token-type :id))
  1021.            (test-for-suspicious-symbol (car *sal-tokens*))))
  1022.     rslt))
  1023.  
  1024.  
  1025. (defun maybe-parse-command ()
  1026.   (if (token-is '(:define :load :chdir :variable :function
  1027.                   ;  :system 
  1028.                   :play :print :display))
  1029.       (parse-command)))
  1030.  
  1031.  
  1032. (defun parse-command ()
  1033.   (cond ((token-is '(:define :variable :function))
  1034.          (parse-declaration))
  1035.         ((token-is :load)
  1036.          (parse-load))
  1037.         ((token-is :chdir)
  1038.          (parse-chdir))
  1039.         ((token-is :play)
  1040.          (parse-play))
  1041. ;        ((token-is :system)
  1042. ;         (parse-system))
  1043.         ((token-is :print)
  1044.          (parse-print-display :print 'sal-print))
  1045.         ((token-is :display)
  1046.          (parse-print-display :display 'display))
  1047. ;        ((token-is :output)
  1048. ;         (parse-output))
  1049.         (t
  1050.          (errexit "Command not found"))))
  1051.  
  1052.  
  1053. (defun parse-stmt ()
  1054.   (cond ((token-is :begin)
  1055.          (parse-block))
  1056.         ((token-is '(:if :when :unless))
  1057.          (parse-conditional))
  1058.         ((token-is :set)
  1059.          (parse-assignment))
  1060.         ((token-is :loop)
  1061.          (parse-loop))
  1062.         ((token-is :print)
  1063.          (parse-print-display :print 'sal-print))
  1064.         ((token-is :display)
  1065.          (parse-print-display :display 'display))
  1066. ;        ((token-is :output)
  1067. ;         (parse-output))
  1068.         ((token-is :exec)
  1069.          (parse-exec))
  1070.         ((token-is :exit)
  1071.          (parse-exit))
  1072.         ((token-is :return)
  1073.          (parse-return))
  1074.         ((token-is :load)
  1075.          (parse-load))
  1076.         ((token-is :chdir)
  1077.          (parse-chdir))
  1078. ;        ((token-is :system)
  1079. ;         (parse-system))
  1080.         ((token-is :play)
  1081.          (parse-play))
  1082.         (t
  1083.          (errexit "Command not found"))))
  1084.         
  1085.  
  1086. ;; GET-PARM-NAMES -- given parms like (a b &key (x 1) (y 2)),
  1087. ;;   return list of parameters: (a b x y)
  1088. (defun get-parm-names (parms)
  1089.   (let (rslt)
  1090.     (dolist (p parms)
  1091.       (cond ((symbolp p) 
  1092.              (if (eq p '&key) nil (push p rslt)))
  1093.             (t (push (car p) rslt))))
  1094.     (reverse rslt)))
  1095.  
  1096.  
  1097. ;; RETURNIZE -- make a statement (list) end with a sal-return-from
  1098. ;;
  1099. ;;   SAL returns nil from begin-end statement lists
  1100. ;;
  1101. (defun returnize (stmt)
  1102.   (let (rev)
  1103.     (setf rev (reverse stmt))
  1104.     (setf expr (car rev)) ; last expression in list
  1105.     (cond ((and (consp expr) (eq (car expr) 'sal-return-from))
  1106.            stmt) ; already ends in sal-return-from
  1107.           (t
  1108.            (reverse (cons (list 'sal-return-from *sal-fn-name* nil)
  1109.                           rev))))))
  1110.  
  1111.  
  1112. (defun parse-declaration ()
  1113.   (if (token-is :define) (parse-token)) ; SAL extension: "define" is optional
  1114.   (let (bindings setf-args formals parms stmt locals loc)
  1115.     (cond ((token-is :variable)
  1116.            (setf bindings (parse-bindings))
  1117.            (setf loc *rslt*) ; the "variable" token
  1118.            (dolist (b bindings)
  1119.              (cond ((symbolp b)
  1120.                     (push b setf-args)
  1121.                     (push `(if (boundp ',b) ,b) setf-args))
  1122.                    (t
  1123.                     (push (first b) setf-args)
  1124.                     (push (second b) setf-args))))
  1125.            (add-line-info-to-stmt (cons 'setf (reverse setf-args)) loc))
  1126.           ((token-is :function)
  1127.            (parse-token)
  1128.            (if (token-is :id nil)
  1129.                (setf *sal-fn-name* (token-lisp (parse-token)))
  1130.                (errexit "function name expected here"))
  1131.            (setf locals *sal-local-variables*)
  1132.            (setf formals (parse-parms))
  1133.            (setf stmt (parse-stmt))
  1134.            ;; stmt may contain a return-from, so make this a progn or prog*
  1135.            (cond ((and (consp stmt) 
  1136.                        (not (eq (car stmt) 'progn))
  1137.                        (not (eq (car stmt) 'prog*)))
  1138.                   (setf stmt (list 'progn stmt))))
  1139.            ;; need return to pop traceback stack
  1140.            (setf stmt (returnize stmt))
  1141.            ;; get list of parameter names
  1142.            (setf parms (get-parm-names formals))
  1143.            (setf *sal-local-variables* locals)
  1144.            ;; build the defun
  1145.            (prog1 (list 'defun *sal-fn-name* formals 
  1146.                         (list 'sal-trace-enter 
  1147.                               (list 'quote *sal-fn-name*) 
  1148.                               (cons 'list parms)
  1149.                               (list 'quote parms))
  1150.                         stmt)
  1151.                   (setf *sal-fn-name* nil)))
  1152.           (t
  1153.            (errexit "bad syntax")))))
  1154.  
  1155.  
  1156. (defun parse-one-parm (kargs)
  1157.   ;; kargs is a flag indicating previous parameter was a keyword (all
  1158.   ;;   the following parameters must then also be keyword parameters)
  1159.   ;; returns: (<keyword> <default>) or (nil <identifier>)
  1160.   ;;   where <keyword> is a keyward parameter name (nil if not a keyword parm)
  1161.   ;;         <default> is an expression for the default value
  1162.   ;;         <identifier> is the parameter name (if not a keyword parm)
  1163.   (let (key default-value id)
  1164.     (cond ((and kargs (token-is :id))
  1165.            (errexit "positional parameter not allowed after keyword parameter"))
  1166.           ((token-is :id)
  1167.            ;(display "parse-one-1" (token-is :id) (car *sal-tokens*))
  1168.            (setf id (token-lisp (parse-token)))
  1169.            (push id *sal-local-variables*)
  1170.            (list nil id))
  1171.           ((token-is :key)
  1172.            (setf key (sal-string-to-symbol (token-string (parse-token))))
  1173.            (cond ((or (token-is :co) (token-is :rp))) ; no default value
  1174.                  (t
  1175.                   (setf default-value (parse-sexpr))))
  1176.            (list key default-value)) 
  1177.           (kargs
  1178.            (errexit "expected keyword name"))
  1179.           (t
  1180.            (errexit "expected parameter name")))))
  1181.  
  1182.  
  1183. (defun parse-parms ()
  1184.   ;(display "parse-parms" *sal-tokens*)
  1185.   (let (parms parm kargs expecting)
  1186.     (if (token-is :lp)
  1187.         (parse-token) ;; eat the left paren
  1188.         (errexit "expected left parenthesis"))
  1189.     (setf expecting (not (token-is :rp)))
  1190.     (while expecting
  1191.       (setf parm (parse-one-parm kargs))
  1192.       ;(display "parm" parm)
  1193.       ;; returns list of (kargs . parm)
  1194.       (if (and (car parm) (not kargs)) ; kargs just set
  1195.           (push '&key parms))
  1196.       (setf kargs (car parm))
  1197.       ;; normally push the <id>; for keyword parms, push id and default value
  1198.       (push (if kargs parm (cadr parm)) parms)
  1199.       (if (token-is :co)
  1200.           (parse-token)
  1201.           (setf expecting nil)))
  1202.     (if (token-is :rp) (parse-token)
  1203.         (errexit "expected right parenthesis"))
  1204.     ;(display "parse-parms" (reverse parms))
  1205.     (reverse parms)))
  1206.  
  1207.  
  1208. (defun parse-bindings ()
  1209.   (let (bindings bind)
  1210.     (setf *rslt* (parse-token)) ; skip "variable" or "with"
  1211.       ; return token as "extra" return value
  1212.     (setf bind (parse-bind))
  1213.     (push (if (second bind) bind (car bind))
  1214.           bindings)
  1215.     (while (token-is :co)
  1216.       (parse-token)
  1217.       (setf bind (parse-bind))
  1218.       ;; if non-nil initializer, push (id expr)
  1219.       (push (if (second bind) bind (car bind))
  1220.             bindings))
  1221.     (reverse bindings)))
  1222.  
  1223.  
  1224. (defun parse-bind ()
  1225.   (let (id val)
  1226.     (if (token-is :id nil)
  1227.         (setf id (token-lisp (parse-token)))
  1228.         (errexit "expected a variable name"))
  1229.     (cond ((token-is :=)
  1230.            (parse-token)
  1231.            (setf val (parse-sexpr))))
  1232.     (push id *sal-local-variables*)
  1233.     (list id val)))
  1234.  
  1235.  
  1236. (defun parse-chdir ()
  1237.   ;; assume next token is :chdir
  1238.   (or (token-is :chdir) (error "parse-chdir internal error"))
  1239.   (let (path loc)
  1240.    (setf loc (parse-token))
  1241.    (setf path (parse-path))
  1242.    (add-line-info-to-stmt (list 'setdir path) loc)))
  1243.  
  1244.  
  1245. (defun parse-play ()
  1246.  ;; assume next token is :play
  1247.  (or (token-is :play) (error "parse-play internal error"))
  1248.  (let ((loc (parse-token)))
  1249.    (add-line-info-to-stmt (list 'sal-play (parse-sexpr)) loc)))
  1250.  
  1251.  
  1252. (defun parse-return ()
  1253.   (or (token-is :return) (error "parse-return internal error"))
  1254.   (let (loc)
  1255.     (if (null *sal-fn-name*)
  1256.         (errexit "Return must be inside a function body"))
  1257.     (setf loc (parse-token))
  1258.     (add-line-info-to-stmt (list 'sal-return-from *sal-fn-name*
  1259.                                  (parse-sexpr)) loc)))
  1260.  
  1261.  
  1262. (defun parse-load ()
  1263.   ;; assume next token is :load
  1264.   (or (token-is :load) (error "parse-load internal error"))
  1265.   (let (path args loc)
  1266.    (setf loc (parse-token))
  1267.    (setf path (parse-path)) ; must return path or raise error
  1268.    (setf args (parse-keyword-args))
  1269.    (add-line-info-to-stmt (cons 'sal-load (cons path args)) loc)))
  1270.  
  1271. (defun parse-keyword-args ()
  1272.   (let (args)
  1273.     (while (token-is :co)
  1274.       (parse-token)
  1275.       (cond ((token-is :key)
  1276.              (push (token-value) args)
  1277.              (push (parse-sexpr) args))))
  1278.     (reverse args)))
  1279.  
  1280.  
  1281. '(defun parse-system ()
  1282.   ;; assume next token is :system
  1283.   (or (token-is :system) (error "parse-system internal error"))
  1284.   (let (path arg args)
  1285.    (parse-token)
  1286.    (setf path (parse-sexpr))
  1287.    (list 'sal-system path)))
  1288.  
  1289.  
  1290. (defun parse-path ()
  1291.   (if (token-is '(:id :string))
  1292.       (token-lisp (parse-token))
  1293.       (errexit "path not found")))
  1294.  
  1295.  
  1296. (defun parse-print-display (token function)
  1297.   ;; assumes next token is :print
  1298.   (or (token-is token) (error "parse-print-display internal error"))
  1299.   (let (args arg loc)
  1300.    (setf loc (parse-token))
  1301.    (setf arg (parse-sexpr))
  1302.    (setf args (list arg))
  1303.    (while (token-is :co)
  1304.     (parse-token) ; remove and ignore the comma
  1305.     (setf arg (parse-sexpr))
  1306.     (push arg args))
  1307.    (add-line-info-to-stmt (cons function (reverse args)) loc)))
  1308.  
  1309.  
  1310. ;(defun parse-output ()
  1311. ; ;; assume next token is :output
  1312. ; (or (token-is :output) (error "parse-output internal error"))
  1313. ; (parse-token)
  1314. ; (list 'sal-output (parse-sexpr)))
  1315.  
  1316.  
  1317. (defun maybe-parse-block ()
  1318.   (if (token-is :begin) (parse-block)))
  1319.  
  1320.  
  1321. (defun parse-block ()
  1322.   ;; assumes next token is :block
  1323.   (or (token-is :begin) (error "parse-block internal error"))
  1324.   (let (args stmts (locals *sal-local-variables*))
  1325.    (parse-token)
  1326.    (cond ((token-is :with)
  1327.           (setf args (parse-bindings))))
  1328.    (while (not (token-is :end))
  1329.     (push (parse-stmt) stmts))
  1330.    (parse-token)
  1331.    (setf stmts (reverse stmts))
  1332.    ;(display "parse-block" args stmts)
  1333.    (setf *sal-local-variables* locals)
  1334.    (cons 'prog* (cons args stmts))))
  1335.  
  1336.  
  1337. ;; MAKE-STATEMENT-LIST -- convert stmt to a stmt list
  1338. ;;
  1339. ;; if it is a (PROGN ...) then return cdr -- it's already a list
  1340. ;; otherwise, put single statement into a list
  1341. ;;
  1342. (defun make-statement-list (stmt)
  1343.   (cond ((atom stmt)
  1344.          (list stmt))
  1345.         ((eq (car stmt) 'progn)
  1346.          (cdr stmt))
  1347.         (t
  1348.          (list stmt))))
  1349.  
  1350. (setf *conditional-tokens* '(:if :when :unless))
  1351.  
  1352.  
  1353. (defun maybe-parse-conditional ()
  1354.   (if (token-is *conditional-tokens*)
  1355.       (parse-conditional)))
  1356.  
  1357.  
  1358. (defun parse-conditional ()
  1359.   ;; assumes next token is :if
  1360.   (or (token-is *conditional-tokens*)
  1361.       (error "parse-conditional internal error"))
  1362.   (let (test then-stmt else-stmt if-token)
  1363.     (cond ((token-is :if)
  1364.            (setf if-token (parse-token))
  1365.            (setf test (parse-sexpr if-token))
  1366.            (if (not (token-is :then))
  1367.                (errexit "expected then after if"))
  1368.            (parse-token)
  1369.            (if (not (token-is :else)) ;; no then statement
  1370.                (setf then-stmt (parse-stmt)))
  1371.            (cond ((token-is :else)
  1372.                   (parse-token)
  1373.                   (setf else-stmt (parse-stmt))))
  1374.            ;(display "cond" test then-stmt else-stmt)
  1375.            (if else-stmt
  1376.                (list 'if test then-stmt else-stmt)
  1377.                (list 'if test then-stmt)))
  1378.           ((token-is :when)
  1379.            (parse-token)
  1380.            (setf test (parse-sexpr))
  1381.            (setf then-stmt (parse-stmt))
  1382.            (cons 'when (cons test (make-statement-list then-stmt))))
  1383.           ((token-is :unless)
  1384.            (parse-token)
  1385.            (setf test (parse-sexpr))
  1386.            (setf else-stmt (parse-stmt))
  1387.            (cons 'unless (cons test (make-statement-list else-stmt)))))))
  1388.  
  1389.  
  1390. (defun maybe-parse-assignment ()
  1391.   (if (token-is :set) (parse-assignment)))
  1392.  
  1393.  
  1394. (defun parse-assignment ()
  1395.   ;; first token must be set
  1396.   (or (token-is :set) (error "parse-assignment internal error"))
  1397.   (let (assignments rslt vref op expr set-token)
  1398.     (setf set-token (parse-token))
  1399.     (push (parse-assign) assignments) ; returns (target op value)
  1400.     (while (token-is :co)
  1401.       (parse-token) ; skip the comma
  1402.       (push (parse-assign) assignments))
  1403.     ; now assignments is ((target op value) (target op value)...)
  1404.     (dolist (assign assignments)
  1405.       (setf vref (first assign) op (second assign) expr (third assign))
  1406.       (cond ((eq op '=))
  1407.             ((eq op '-=) (setf expr `(diff ,vref ,expr)))
  1408.             ((eq op '+=) (setf expr `(sum ,vref ,expr)))
  1409.         ((eq op '*=) (setq expr `(mult ,vref ,expr)))
  1410.         ((eq op '/=) (setq expr `(/ ,vref ,expr)))
  1411.         ((eq op '&=) (setq expr `(nconc ,vref (list ,expr))))
  1412.         ((eq op '@=) (setq expr `(cons ,expr ,vref)))
  1413.             ((eq op '^=) (setq expr `(nconc ,vref (copy-list ,expr))))
  1414.         ((eq op '<=) (setq expr `(min ,vref ,expr)))
  1415.         ((eq op '>=) (setq expr `(max ,vref ,expr)))
  1416.         (t (errexit (format nil "unknown assigment operator ~A" op))))
  1417.       (push (list 'setf vref expr) rslt))
  1418.     (setf rslt (add-line-info-to-stmts rslt set-token))
  1419.     (if (> (length rslt) 1)
  1420.         (cons 'progn rslt)
  1421.         (car rslt))))
  1422.  
  1423.     
  1424. ;; PARSE-ASSIGN -- based on parse-bind, but with different operators
  1425. ;;
  1426. ;; allows arbitrary term on left because it could be an array
  1427. ;; reference. After parsing, we can check that the target of the
  1428. ;; assignment is either an identifier or an (aref ...)
  1429. ;;
  1430. (defun parse-assign ()
  1431.   (let ((lhs (parse-term) op val))
  1432.     (cond ((token-is '(:= :-= :+= :*= :/= :&= :@= :^= :<= :>=))
  1433.            (setf op (parse-token))
  1434.            (setf op (if (eq (token-type op) ':=) '= (token-lisp op)))
  1435.            (setf val (parse-sexpr))))
  1436.     (cond ((and (consp lhs) (eq (car lhs) 'aref))) ;; aref good
  1437.           ((symbolp lhs)) ;; id good
  1438.           (t (errexit "expected a variable name or array reference")))
  1439.     (list lhs op val)))
  1440.  
  1441.  
  1442. (defun maybe-parse-loop ()
  1443.   (if (token-is :loop) (parse-loop)))
  1444.  
  1445.  
  1446. ;; loops are compiled to do*
  1447. ;; bindings go next as usual, but bindings include for variables
  1448. ;; and repeat is converted to a for +count+ from 0 to <sexpr>
  1449. ;; stepping is done after statement
  1450. ;; termination clauses are combined with OR and
  1451. ;; finally goes after termination
  1452. ;; statement goes in do* body
  1453. ;;
  1454. (defun parse-loop ()
  1455.   (or (token-is :loop) (error "parse-loop: internal error"))
  1456.   (let (bindings termination-tests stmts sexpr rslt finally
  1457.         loc
  1458.         (locals *sal-local-variables*))
  1459.     (parse-token) ; skip "loop"
  1460.     (if (token-is :with)
  1461.         (setf bindings (reverse (parse-bindings))))
  1462.     (while (token-is '(:repeat :for))
  1463.       (cond ((token-is :repeat)
  1464.              (setf loc (parse-token))
  1465.              (push (list 'sal:loopcount 0 '(1+ sal:loopcount)) bindings)
  1466.              (setf sexpr (parse-sexpr loc)) ; get final count expression
  1467.              (push (list 'sal:loopfinal sexpr) bindings)
  1468.              (push '(>= sal:loopcount sal:loopfinal) termination-tests))
  1469.             ((token-is :for)
  1470.              (setf rslt (parse-for-clause))
  1471.              ; there can be multiple bindings, build bindings in reverse
  1472.              (cond ((first rslt)
  1473.                     (setf bindings (append (reverse (first rslt))
  1474.                                            bindings))))
  1475.              (if (second rslt) (push (second rslt) termination-tests)))))
  1476.     (while (token-is '(:while :until))
  1477.       (cond ((token-is :while)
  1478.              (setf loc (parse-token))
  1479.              (push (list 'not (parse-sexpr loc)) termination-tests))
  1480.             ((token-is :until)
  1481.              (setf loc (parse-token))
  1482.              (push (parse-sexpr loc) termination-tests))))
  1483.     ; (push (parse-stmt) stmts)
  1484.     (while (not (token-is '(:end :finally)))
  1485.       (push (parse-stmt) stmts))
  1486.     (cond ((token-is :finally)
  1487.            (parse-token) ; skip "finally"
  1488.            (setf finally (parse-stmt))))
  1489.     (if (token-is :end)
  1490.         (parse-token)
  1491.         (errexit "expected end after loop"))
  1492.     (setf *sal-local-variables* locals)
  1493.     `(do* ,(reverse bindings)
  1494.           ,(list (or-ize (reverse termination-tests)) finally) 
  1495.           ,@(reverse stmts))))
  1496.  
  1497.  
  1498. ;; OR-IZE -- compute the OR of a list of expressions
  1499. ;;
  1500. (defun or-ize (exprs)
  1501.  (if (> 1 (length exprs)) (cons 'or exprs)
  1502.      (car exprs)))
  1503.  
  1504.  
  1505. (defun maybe-parse-exec ()
  1506.   (if (token-is :exec) (parse-exec)))
  1507.  
  1508.  
  1509. (defun parse-exec ()
  1510.   (or (token-is :exec) (error "parse-exec internal error"))
  1511.   (let ((loc (parse-token))) ;  skip the :exec
  1512.     (parse-sexpr loc)))
  1513.           
  1514.  
  1515. (defun maybe-parse-exit ()
  1516.   (if (token-is :exit) (parse-exit)))
  1517.  
  1518.  
  1519. (defun parse-exit ()
  1520.   (let (tok loc)
  1521.     (or (token-is :exit) (error "parse-exit internal error"))
  1522.     (setf loc (parse-token)) ; skip the :exit
  1523.     (cond ((token-is :id)
  1524.            (setf tok (parse-token))
  1525.            (cond ((eq (token-lisp tok) 'nyquist)
  1526.                   (add-line-info-to-stmt '(exit) loc))
  1527.                  ((eq (token-lisp tok) 'sal)
  1528.                   (add-line-info-to-stmt '(sal-exit) loc))
  1529.                  (t
  1530.                   (errexit "expected \"nyquist\" or \"sal\" after \"exit\""))))
  1531.           (t
  1532.            (add-line-info-to-stmt '(sal-exit) loc)))))
  1533.  
  1534.  
  1535. ;; PARSE-FOR-CLAUSE - returns (bindings term-test)
  1536. ;;
  1537. (defun parse-for-clause ()
  1538.   (or (token-is :for) (error "parse-for-clause: internal error"))
  1539.   (let (id init next rslt binding term-test list-id loc)
  1540.     (setf loc (parse-token)) ; skip for
  1541.     (if (token-is :id)
  1542.         (setf id (token-lisp (parse-token)))
  1543.         (errexit "expected identifier after for"))
  1544.     (cond ((token-is :=)
  1545.            ;; if the clause is just for id = expr, then assume that
  1546.            ;; expr depends on something that changes each iteration:
  1547.            ;; recompute and assign expr to id each time around
  1548.            (parse-token) ; skip "="
  1549.            (setf init (parse-sexpr loc))
  1550.            (cond ((token-is :then)
  1551.                   (parse-token) ; skip "then"
  1552.                   (setf binding (list id init (parse-sexpr loc))))
  1553.                  (t
  1554.                   (setf binding (list id init init))))
  1555.            (setf binding (list binding)))
  1556.           ((token-is :in)
  1557.            (setf loc (parse-token)) ; skip "in"
  1558.            (setf list-id (intern (format nil "SAL:~A-LIST" id)))
  1559.            (setf binding 
  1560.                  (list (list list-id (parse-sexpr loc)
  1561.                              (list 'cdr list-id))
  1562.                        (list id (list 'car list-id) (list 'car list-id))))
  1563.            (setf term-test (list 'null list-id)))
  1564.           ((token-is :over)
  1565.            (setf loc (parse-token)) ; skip "over"
  1566.            (setf start (parse-sexpr loc))
  1567. #|         (cond ((token-is :by)
  1568.                   (parse-token) ; skip "by"
  1569.                   (parse-sexpr))) ;-- I don't know what "by" means - RBD |#
  1570.            (setf list-id (intern (format nil "SAL:~A-PATTERN" id)))
  1571.            (setf binding
  1572.                  (list (list list-id start)
  1573.                        (list id (list 'next list-id) (list 'next list-id)))))
  1574.           ((token-is '(:from :below :to :above :downto :by))
  1575.            (cond ((token-is :from)
  1576.                   (setf loc (parse-token)) ; skip "from"
  1577.                   (setf init (parse-sexpr loc)))
  1578.                  (t
  1579.                   (setf init 0)))
  1580.            (cond ((token-is :below)
  1581.                   (setf loc (parse-token)) ; skip "below"
  1582.                   (setf term-test (list '>= id (parse-sexpr loc))))
  1583.                  ((token-is :to)
  1584.                   (setf loc (parse-token)) ; skip "to"
  1585.                   (setf term-test (list '> id (parse-sexpr loc))))
  1586.                  ((token-is :above)
  1587.                   (setf loc (parse-token)) ; skip "above"
  1588.                   (setf term-test (list '<= id (parse-sexpr loc))))
  1589.                  ((token-is :downto)
  1590.                   (setf loc (parse-token)) ; skip "downto"
  1591.                   (setf term-test (list '< id (parse-sexpr loc)))))
  1592.            (cond ((token-is :by)
  1593.                   (setf loc (parse-token)) ; skip "by"
  1594.                   (setf binding (list id init (list '+ id (parse-sexpr loc)))))
  1595.                  ((or (null term-test)
  1596.                       (and term-test (member (car term-test) '(>= >))))
  1597.                   (setf binding (list id init (list '1+ id))))
  1598.                  (t ; loop goes down because of "above" or "downto"
  1599.                   (display "for step" term-test)
  1600.                   (setf binding (list id init (list '1- id)))))
  1601.            (setf binding (list binding)))
  1602.           (t
  1603.            (errexit "for statement syntax error")))
  1604.     (list binding term-test)))
  1605.  
  1606.     
  1607. ;; parse-sexpr works by building a list: (term op term op term ...)
  1608. ;; later, the list is parsed again using operator precedence rules
  1609. (defun parse-sexpr (&optional loc)
  1610.   (let (term rslt)
  1611.     (push (parse-term) rslt)
  1612.     (while (token-is *sal-operators*)
  1613.       (push (token-type (parse-token)) rslt)
  1614.       (push (parse-term) rslt))
  1615.     (setf rslt (reverse rslt))
  1616.     ;(display "parse-sexpr before inf->pre" rslt)
  1617.     (setf rslt (if (consp (cdr rslt))
  1618.                 (inf->pre rslt)
  1619.                 (car rslt)))
  1620.     (if loc
  1621.         (setf rslt (add-line-info-to-expression rslt loc)))
  1622.     rslt))
  1623.  
  1624.  
  1625. (defun get-lisp-op (op)
  1626.   (third (assoc op +operators+)))
  1627.  
  1628.  
  1629. ;; a term is <unary-op> <term>, or
  1630. ;;           ( <sexpr> ), or
  1631. ;;           ? ( <sexpr> , <sexpr> , <sexpr> ), or
  1632. ;;           <id>, or
  1633. ;;           <id> ( <args> ), or
  1634. ;;           <term> [ <sexpr> ]
  1635. ;; Since any term can be followed by indexing, handle everything
  1636. ;; but the indexing here in parse-term-1, then write parse-term
  1637. ;; to do term-1 followed by indexing operations
  1638. ;;
  1639. (defun parse-term-1 ()
  1640.   (let (sexpr id)
  1641.     (cond ((token-is '(:- :!))
  1642.            (list (token-lisp (parse-token)) (parse-term)))
  1643.           ((token-is :lp)
  1644.            (parse-token) ; skip left paren
  1645.            (setf sexpr (parse-sexpr))
  1646.            (if (token-is :rp)
  1647.                (parse-token)
  1648.                (errexit "right parenthesis not found"))
  1649.            sexpr)
  1650.           ((token-is :?)
  1651.            (parse-ifexpr))
  1652.           ((token-is :lc)
  1653.            (list 'quote (parse-list)))
  1654.           ((token-is '(:int :float :bool :list :string))
  1655.            ;(display "parse-term int float bool list string" (car *sal-tokens*))
  1656.            (token-lisp (parse-token)))
  1657.           ((token-is :id) ;; aref or funcall
  1658.            (setf id (token-lisp (parse-token)))
  1659.            ;; array indexing was here, but that only allows [x] after
  1660.            ;; identifiers. Move this to expression parsing.
  1661.            (cond ((token-is :lp)
  1662.                   (parse-token)
  1663.                   (setf sexpr (cons id (parse-pargs t)))
  1664.                   (if (token-is :rp)
  1665.                       (parse-token)
  1666.                       (errexit "right paren not found"))
  1667.                   sexpr)
  1668.                  (t id)))
  1669.           (t
  1670.            (errexit "expression not found")))))
  1671.  
  1672.  
  1673. (defun parse-term ()
  1674.   (let ((term (parse-term-1)))
  1675.     ; (display "parse-term" term (token-is :lb))
  1676.     (while (token-is :lb)
  1677.       (parse-token)
  1678.       (setf term (list 'aref term (parse-sexpr)))
  1679.       (if (token-is :rb)
  1680.           (parse-token)
  1681.           (errexit "right bracket not found")))
  1682.     term))
  1683.  
  1684.  
  1685. (defun parse-ifexpr ()
  1686.   (or (token-is :?) (error "parse-ifexpr internal error"))
  1687.   (let (condition then-sexpr else-sexpr)
  1688.     (parse-token) ;  skip the :?
  1689.     (if (token-is :lp) (parse-token) (errexit "expected left paren"))
  1690.     (setf condition (parse-sexpr))
  1691.     (if (token-is :co) (parse-token) (errexit "expected comma"))
  1692.     (setf then-sexpr (parse-sexpr))
  1693.     (if (token-is :co) (parse-token) (errexit "expected comma"))
  1694.     (setf else-sexpr (parse-sexpr))
  1695.     (if (token-is :rp) (parse-token) (errexit "expected left paren"))
  1696.     (list 'if condition then-sexpr else-sexpr)))
  1697.  
  1698.  
  1699. (defun keywordp (s)
  1700.   (and (symbolp s) (eq (type-of (symbol-name s)) 'string)
  1701.        (equal (char (symbol-name s) 0) #\:)))
  1702.  
  1703.  
  1704. (defun functionp (x) (eq (type-of x) 'closure))
  1705.  
  1706.  
  1707. (defun parse-pargs (keywords-allowed)
  1708.   ;; get a list of sexprs. If keywords-allowed, then at any point
  1709.   ;; the arg syntax can switch from [<co> <sexpr>]* to
  1710.   ;; [<co> <keyword> <sexpr>]*
  1711.   ;; also if keywords-allowed, it's a function call and the
  1712.   ;; list may be empty. Otherwise, it's a list of indices and
  1713.   ;; the list may not be empty
  1714.   (let (pargs keyword-expected sexpr keyword)
  1715.    (if (and keywords-allowed (token-is :rp))
  1716.        nil ; return empty parameter list
  1717.        (loop ; look for one or more [keyword] sexpr
  1718.          ; optional keyword test
  1719.          (setf keyword nil)
  1720.          ;(display "pargs" (car *sal-tokens*))
  1721.          (if (token-is :key)
  1722.              (setf keyword (token-lisp (parse-token))))
  1723.          ; (display "parse-pargs" keyword)
  1724.          ; did we need a keyword?
  1725.          (if (and keyword-expected (not keyword))
  1726.              (errexit "expected keyword"))
  1727.          ; was a keyword legal
  1728.          (if (and keyword (not keywords-allowed))
  1729.              (errexit "keyword not allowed here"))
  1730.          (setf keyword-expected keyword) ; once we get a keyword, we need
  1731.                                          ; one before each sexpr
  1732.          ; now find sexpr
  1733.          (setf sexpr (parse-sexpr))
  1734.          (if keyword (push keyword pargs))
  1735.          (push sexpr pargs)
  1736.          ; (display "parse-pargs" keyword sexpr pargs)
  1737.          (cond ((token-is :co)
  1738.                 (parse-token))
  1739.                (t
  1740.                 (return (reverse pargs))))))))
  1741.  
  1742.  
  1743. ;; PARSE-LIST -- parse list in braces {}, return list not quoted list
  1744. ;;
  1745. (defun parse-list ()
  1746.   (or (token-is :lc) (error "parse-list internal error"))
  1747.   (let (elts)
  1748.     (parse-token)
  1749.     (while (not (token-is :rc))
  1750.            (cond ((token-is '(:int :float :id :bool :key :string))
  1751.                   (push (token-lisp (parse-token)) elts))
  1752.                  ((token-is :lc)
  1753.                   (push (parse-list) elts))
  1754.                  (t
  1755.                   (errexit "expected list element or right brace"))))
  1756.     (parse-token)
  1757.     (reverse elts)))
  1758.  
  1759.  
  1760. (defparameter *op-weights*
  1761.   '(
  1762.     (:\| 1)
  1763.     (:& 2)
  1764.     (:! 3)
  1765.     (:= 4)
  1766.     (:!= 4)
  1767.     (:> 4)
  1768.     (:>= 4)
  1769.     (:< 4)
  1770.     (:<= 4)
  1771.     (:~= 4) ; general equality
  1772.     (:+ 5)
  1773.     (:- 5)
  1774.     (:% 5)
  1775.     (:* 6)
  1776.     (:/ 6)
  1777.     (:^ 7)
  1778.     (:~ 8)
  1779.     (:~~ 8)
  1780.     (:@ 8)
  1781.     (:@@ 8)))
  1782.  
  1783.  
  1784. (defun is-op? (x)
  1785.   ;; return op weight if x is operator
  1786.   (let ((o (assoc (if (listp x) (token-type x) x)
  1787.          *op-weights*)))
  1788.     (and o (cadr o))))
  1789.  
  1790.  
  1791. (defun inf->pre (inf)
  1792.   ;; this does NOT rewrite subexpressions because parser applies rules
  1793.   ;; depth-first so subexprs are already processed
  1794.   (let (op lh rh w1)
  1795.     (if (consp inf)
  1796.     (do ()
  1797.         ((null inf) lh)
  1798.       (setq op (car inf))        ; look at each element of in
  1799.           (pop inf)
  1800.       (setq w1 (is-op? op))
  1801.       (cond ((numberp w1)        ; found op (w1 is precedence)
  1802.          (do ((w2 nil)
  1803.               (ok t)
  1804.               (li (list)))
  1805.              ((or (not inf) (not ok))
  1806.               (setq rh (inf->pre (nreverse li)))
  1807.               (setq lh (if lh (list (get-lisp-op op) lh rh)
  1808.                    (list (get-lisp-op op) rh nil))))
  1809.            (setq w2 (is-op? (first inf)))
  1810.            (cond ((and w2 (<= w2 w1))
  1811.                   (setq ok nil))
  1812.                          (t
  1813.                           (push (car inf) li)
  1814.                           (pop inf)))))
  1815.         (t
  1816.          (setq lh op))))
  1817.     inf)))
  1818.  
  1819.